Read in questionnaire:

filler_items = read.csv("./judgments/all/LikertSkala_filler.csv", fileEncoding = "UTF-8")
test_items = read.csv("./judgments/all/LikertSkala_test.csv", fileEncoding = "UTF-8") %>% 
  mutate(ITEM_FUNCTION = "test")
questionnaire = bind_rows(filler_items, test_items) %>%
  mutate_at(.vars = c("CONDITION_NO","KEY_CONDITION", "workerId"), .funs = as_factor)

1 Progress (incomplete submissions)

We require that at least 90% of the questionnaire has been completed. (Note: we assume that there are no missing trials due to data loss / technical errors).

available_trials = questionnaire %>%
  group_by(workerId) %>%
  summarise(trials = n(), 
            trials_prop = n()/length(unique(questionnaire$trial_index))) %>%
  mutate(accept = ifelse(trials_prop < 0.9, FALSE, TRUE)) %>%
  arrange(trials_prop)

Let’s check whether there are participants that left the questionnaire prematurely:

available_trials %>% filter(trials_prop < 1) %>% kable()
workerId trials trials_prop accept
207 3 0.028 FALSE
204 65 0.602 FALSE

Remove incomplete data from questionnaire:

 questionnaire = questionnaire %>%
   filter(!(workerId %in% (
     available_trials %>% filter(accept == FALSE) %>% pull(workerId)
   )))

2 Latency-based identification

2.1 Spammers

We will reject workers with mean(RT) < 3000 ms (as simple spammers) and those with median(RT) < 3000 ms (as clever spammers):

simple_spammer = questionnaire %>%
                         group_by(workerId) %>%
                         summarise(score = mean(rt)) %>%
                         mutate(criterion = "meanRT", 
                                accept = ifelse(score < 3000, FALSE, TRUE))

Are there any simple spammers?

simple_spammer %>% filter(accept == FALSE) %>% kable()
workerId score criterion accept 
clever_spammer = questionnaire %>%
                         group_by(workerId) %>%
                         summarise(score = median(rt)) %>%
                         mutate(criterion = "medianRT", 
                                accept = ifelse(score < 3000, FALSE, TRUE))

Are there any clever spammers?

clever_spammer %>% filter(accept == FALSE) %>% kable()
workerId score criterion accept

2.2 RT distributions

Participants and different (groups of) items presumably exhibit different RT distributions:

rt_density_worker = questionnaire %>%
  ggplot(aes(x=log(rt), group = workerId)) + 
  geom_density(alpha=.3, fill = "#DFF1FF")

rt_density_item_funs = questionnaire %>% 
  ggplot(aes(x = log(rt), fill=ITEM_FUNCTION)) +
  geom_density(alpha=.3) + 
  scale_fill_brewer(palette = "Greys")

Figure 1 in Pieper et al. (2022)

The more diverse the distribution the stronger is the superiority of ReMFOD (see next chapter) above generic cutoff points for outlier detection.

2.3 Underperforming

Recursive multi-factorial outlier detection (ReMFOD , Pieper et al. (2022))

source("./R Sources/ReMFOD.R")

ReMFOD (see source code) aims at identifying individual trials as genuine intermissions and rushes. In doing so, ReMFOD accounts for different RT distributions of different participants and item functions, as well as swamping and masking effects. Underpinned by these suspicious individual trials, underperforming participants can be determined by means of proportion of trials not responded to wholeheartedly. We propose to discard participants who have responded genuinely to less than 90~% of trials because they supposedly did not meet the task with the necessary seriousness.

To account for different RT distributions, ReMFOD compares the RT of each trial to a lower and an upper cutoff point, which each consider two cutoff criteria, respectively: The first criterion is computed with respect to the group of trials with the same item function (i.e. attention trials only, control trials only, etc.) regardless of the participant responding, the second one is computed with respect to all trials of the corresponding participant (regardless of the item function). Only if an RT surmounts or falls below both criteria, it will be designated as a genuine intermission or as a genuine rush.1

\[\begin{align} \label{eq:cutoff_outlier_rt} \textit{cutoff_}&\textit{intermission} = \max \left\{ \right.\\ &\left. \text{median}(\textit{RTs:participant}) + 2.5 \times \text{mad}(\textit{RTs:participant}), \right.\nonumber\\ &\left. \text{median}(\textit{RTs:item_function}) + 2.5 \times \text{mad}(\textit{RTs:item_function})\right.\nonumber\} \end{align}\]

\[\begin{align} \label{eq:cutoff_guesses_rt} \textit{cutoff_}&\textit{rush} = \min \left\{ \right.\\ &\left. \text{median}(\textit{RTs:participant}) - 1.5 \times \text{mad}(\textit{RTs:participant}), \right.\nonumber\\ &\left. \text{median}(\textit{RTs:item_function}) - 1.5 \times \text{mad}(\textit{RTs:item_function})\right.\nonumber\} \end{align}\]

To account for swamping and masking effects (see Ben-Gal (2005)), the process described above will be repeated on a reduced data set (i.e. excluding already detected outliers) until no more outliers can be found. Therefore, in each iteration step, the cutoff points must be computed afresh.

2.3.1 Overview plot for item functions

Different outlier types, computed with respect to different groups, are marked by different shapes: Box-shaped trials are the only RTs we consider as genuine intermissions or rushes. Note that the shapes may overlap as these outliers have been computed by various procedures differing in the groups they included to identify outliers.

## compute different outlier types based on the whole questionnaire and plot these
remfod_plot = questionnaire  %>% outlier_plots_remfod()
item_plot = remfod_plot # we are going to reuse remfod_plot for workers
## remove data we are currently not interested in from the plot 
item_plot$data = item_plot$data %>% 
  filter(!ITEM_FUNCTION %in% c("calibration", "filler"))
## structure plot as you like
item_plot + facet_wrap(~ ITEM_FUNCTION, nrow = 1)

2.3.2 Performance of participants

We expect that 90 % of the trials are answered without genuine intermission or rushes, i.e. that 90 % of the RTs are valid

rt_outlier_count = remfod(questionnaire)  %>% 
  group_by(workerId,  direction) %>% tally() %>%
  spread(key = "direction", value = "n") %>% 
  rename( none = "<NA>") %>%  
  mutate_if(is.numeric, replace_na, 0) %>%
  mutate(trials_total = sum(long, short, none),
         prop_long = long/trials_total, 
         prop_short = short/trials_total,
         prop_out = (short+long)/trials_total,
         prop_valid = none/trials_total,
         accept = ifelse(prop_valid < 0.9, FALSE, TRUE)) %>%
  arrange(prop_valid) %>%
  mutate_if(is.numeric, round, 4)

2.3.2.1 Plots of individual participants

Some underperforming participants

Further exemplative workers

3 Item-based identification

control_trials = questionnaire %>% 
  filter(ITEM_FUNCTION == "control")  %>%
  droplevels()

attention_trials = questionnaire %>% 
  filter(ITEM_FUNCTION == "attention")  %>%
  droplevels()

Each control group should provide chances of less than 5% to pass controls by guessing.

3.1 Guessing probabilities

source("./R Sources/GuessingProbs.R")

To compute the probability (by standard binomial expansions) of (exactly!) k correct answers out of N trials, where

  • k amount of trials answered correctly
  • N mount of total trials
  • p the probability of a correct response
  • q the probability of an incorrect response

we can use the formula (see Frederick & Speed (2007)), implemented by the function k_out_of_N:

\[\begin{align} \label{eq:probs_binomial} \frac{N!}{k!(N - k)!}&p^{k}q^{N-k}\text{, where} \\ p &= \text{ probability of a correct response} \nonumber \\ q &= \text{ probability of an incorrect response} \nonumber \end{align}\]

To compute the probability (by standard binomial expansions) of k or fewer correct answers out of N trials, we can use the function k_out_of_N_cumulative, which returns the sum of all the probabilities from 0 to k (see source code).

3.2 Criterion selection

Attention trials only exist in ungrammatical conditions, the analysis hence amounts to counting acceptable response.

Let’s look at the chances to answer at least k out of N items correct if three of the options are considered correct, and two incorrect in a 5-pt-LS are considered correct:

k_out_of_N_matrix_cumulative(p = 3/5, Ns = seq(4,16,2), ks = c(2:12))
Table 3a in Pieper et al. (2022)
N/th> 2 3 4 5 6 7 8 9 10 11 12
4 0.821 0.475 0.130
6 0.959 0.821 0.544 0.233 0.047
8 0.991 0.950 0.826 0.594 0.315 0.106 0.017
10 0.998 0.988 0.945 0.834 0.633 0.382 0.167 0.046 0.006
12 1.000 0.997 0.985 0.943 0.842 0.665 0.438 0.225 0.083 0.020 0.002
14 1.000 0.999 0.996 0.982 0.942 0.850 0.692 0.486 0.279 0.124 0.040
16 1.000 1.000 0.999 0.995 0.981 0.942 0.858 0.716 0.527 0.329 0.167

If we assume a probability of less than 5~% to pass a test by chance and combine it with the qualification that not all trials need to be answered correctly, it follows that nine out of ten trials need to be responded to correctly.

If we take the neutral point not to be acceptable, this number is reduced to five correct responses out of six trials:

k_out_of_N_matrix_cumulative(p = 2/5, Ns = seq(4,16,2), ks = c(2:12))
Table 3b in Pieper et al. (2022)
N/th> 2 3 4 5 6 7 8 9 10 11 12
4 0.525 0.179 0.026
6 0.767 0.456 0.179 0.041 0.004
8 0.894 0.685 0.406 0.174 0.050 0.009 0.001
10 0.954 0.833 0.618 0.367 0.166 0.055 0.012 0.002 0.000
12 0.980 0.917 0.775 0.562 0.335 0.158 0.057 0.015 0.003 0.000 0.000
14 0.992 0.960 0.876 0.721 0.514 0.308 0.150 0.058 0.018 0.004 0.001
16 0.997 0.982 0.935 0.833 0.671 0.473 0.284 0.142 0.058 0.019 0.005

As we stick to the positional account for control trials (see Pieper et al. (2022)), we need to evaluate grammatical and ungrammatical trials separately.

On a positional account, the assessment of participants’ performance is carried out separately for grammatical (CONDTION_NO == 1) and ungrammatical (CONDTION_NO == 2) stimuli, focusing on the pertinent side of the scale in each case. We recommend allowing the neutral point as legitimate response to grammatical stimuli but not to ungrammatical stimuli as it does neither reliably indicate the rejection of the grammatical version nor the rejection of the ungrammatical version. The chance to pass control trials is then the joint probability of passing the two groups individually. Regarding our rule of thumb, these shall not exceed 5%.

Let’s have a look at some joint probabilities for up to eight trials per group, where group sizes are equal.

probs_joint = do.call(rbind, lapply(1:8,function(i){
  probs_joint_positional(i, 3/5, # N, p grammatical
                         i, 2/5) #N, p ungrammatical
}))

To receive more balanced options, we further set the constraints that passing grammatical and ungrammatical trials needs to be below 0.6 and that \(k\) needs to be less than \(N\) in both conditions.

probs_joint %>%
  filter(joint_probs <= 0.05 & gram_probs < 0.6 & ungram_probs < 0.6) %>%
  filter(gram_k < gram_N & ungram_k < ungram_N) %>%
  mutate_if(is.numeric, round, digits = 4) %>%
  unite(N, gram_N, ungram_N, sep = "-") %>% relocate(N) %>%
  arrange(N, ungram_k) %>%
  kable(caption = "Table 4 in @Pieper_et_al_2022")
Table 4 in Pieper et al. (2022)
N gram_k gram_probs ungram_k ungram_probs joint_probs
5-5 4 0.337 4 0.087 0.029
6-6 5 0.233 4 0.179 0.042
6-6 4 0.544 5 0.041 0.022
6-6 5 0.233 5 0.041 0.010
7-7 6 0.159 4 0.290 0.046
7-7 5 0.420 5 0.096 0.040
7-7 6 0.159 5 0.096 0.015
7-7 5 0.420 6 0.019 0.008
7-7 6 0.159 6 0.019 0.003
8-8 7 0.106 4 0.406 0.043
8-8 7 0.106 5 0.174 0.018
8-8 5 0.594 6 0.050 0.030
8-8 6 0.315 6 0.050 0.016
8-8 7 0.106 6 0.050 0.005
8-8 5 0.594 7 0.009 0.005
8-8 6 0.315 7 0.009 0.003
8-8 7 0.106 7 0.009 0.001

3.2.1 Evaluation groups

There are different ways to proceed: we could evaluate attention and control items as one group, evaluate them separately, and even evaluate related and unrelated control items separately. The best choice may depend on the exact nature of your trials. We are going to compute evaluations based on all groups mentioned.

To facilitate computation, we combine the different groups (named by ITEM_FUNCTION) into a single frame – whereby adapting ITEM_FUNCTION in some cases:

eval_trials = rbind(control_trials, attention_trials) %>% 
  # attenion or control items evaluated as one group
  mutate(ITEM_FUNCTION = "attention|control") %>% 
  bind_rows(attention_trials) %>%
  bind_rows(control_trials) %>% 
  # separate evaluation of related and unrelated control trials
  bind_rows(control_trials %>% 
                     mutate(ITEM_FUNCTION = paste(ITEM_FUNCTION, ITEM_SUBGROUP, sep="_"))
                   )

Find number of trials in each group (per questionnaire):

Ns =   eval_trials %>% 
  select(ITEM_FUNCTION, CONDITION_NO, itemId) %>%
  distinct() %>% 
  group_by(ITEM_FUNCTION, CONDITION_NO) %>% 
  tally() %>%
  spread(key = CONDITION_NO, value = n, sep = "_") %>%
  mutate_if(is.numeric, replace_na, 0)
ITEM_FUNCTION CONDITION_NO_1 CONDITION_NO_2
attention 0 12
attention|control 12 24
control 12 12
control_related 6 6
control_unrelated 6 6

compute joint probabilities (of passing grammatical and ungrammatical trials):

probs_joint = mapply(probs_joint_positional,
       Ns$CONDITION_NO_1, 3/5, Ns$CONDITION_NO_2, 2/5) %>%
  t() %>% 
  as.data.frame() %>%
  mutate(ITEM_FUNCTION = Ns$ITEM_FUNCTION) %>% 
  relocate(ITEM_FUNCTION) %>%
  unnest(cols = names(.))

Note: we may now have inbalanced group sizes. Find required k to each group:

eval_criteria = probs_joint %>% 
  filter(joint_probs <= 0.05) %>%
                            ## do not remove attention           
  filter((gram_probs < 0.5||gram_probs == 1) & ungram_probs < 0.5) %>%
                            ## do not remove attention
  filter((gram_k < gram_N || gram_N == 0) & ungram_k < ungram_N) %>% 
  mutate_if(is.numeric, round, digits = 3)  %>%
  group_by(ITEM_FUNCTION) %>%
  slice_max(joint_probs)

suggested thresholds (i.e. minimal requirements)

ITEM_FUNCTION gram_k gram_N gram_probs ungram_k ungram_N ungram_probs joint_probs
attention 0 0 1.000 9 12 0.015 0.015
attention|control 9 12 0.225 12 24 0.213 0.048
control 6 12 0.842 8 12 0.057 0.048
control_related 5 6 0.233 4 6 0.179 0.042
control_unrelated 5 6 0.233 4 6 0.179 0.042

put in long format:

eval_criteria_long = rbind(
  eval_criteria %>% 
    select(ITEM_FUNCTION, starts_with("gram")) %>%
    rename_all(~stringr::str_replace(.,"^gram_","")) %>%
    mutate(CONDITION_NO = 1)
  ,
  eval_criteria %>% 
    select(ITEM_FUNCTION, starts_with("ungram")) %>%
    rename_all(~stringr::str_replace(.,"^ungram_","")) %>%
    mutate(CONDITION_NO = 2)
) %>% 
  rowwise() %>%
  mutate(prop_k = k/N) %>%
  relocate(CONDITION_NO, .after = ITEM_FUNCTION) %>%
  arrange(ITEM_FUNCTION)
ITEM_FUNCTION CONDITION_NO k N probs prop_k
attention 1 0 0 1.000
attention 2 9 12 0.015 0.750
attention|control 1 9 12 0.225 0.750
attention|control 2 12 24 0.213 0.500
control 1 6 12 0.842 0.500
control 2 8 12 0.057 0.667
control_related 1 5 6 0.233 0.833
control_related 2 4 6 0.179 0.667
control_unrelated 1 5 6 0.233 0.833
control_unrelated 2 4 6 0.179 0.667

count correct responses and compare to number of required correct responses

item_based_eval = 
  eval_trials %>% 
  mutate(ANSWER_correct = ifelse(CONDITION_NO == 1, # grammatical
                                  ifelse(ANSWER < 3, "incorrect", "correct"), 
                                 #ungrammatical 
                                  ifelse(ANSWER < 3, "correct", "incorrect"))) %>%
  group_by(workerId, ITEM_FUNCTION, CONDITION_NO, ANSWER_correct) %>% 
  tally() %>% ungroup(workerId) %>%
  spread(key = ANSWER_correct, value = n) %>% 
  mutate_if(is.numeric, replace_na,0) %>% 
  ## we use proportions in order to deal with potentially missing data
  mutate(prop_correct = correct / (correct+incorrect)) %>%
  merge(eval_criteria_long) %>% 
  mutate(accept = ifelse(prop_correct < prop_k, FALSE, TRUE)) %>%
  arrange(prop_correct)

4 Rejected participants

Let’s have a look at the criteria we used to evaluate participants:

unique(worker_profile$criterion)
##  [1] "progress"            "meanRT"              "medianRT"           
##  [4] "validRTs"            "attention_2"         "attention|control_2"
##  [7] "control_2"           "control_related_2"   "control_unrelated_2"
## [10] "control_related_1"   "attention|control_1" "control_1"          
## [13] "control_unrelated_1"

If we applied all of those criteria, and reject all participants who failed on any of them, how many participants would we be left with, i.e. accept?

worker_acceptance = worker_profile %>%
  select(-score) %>%
  group_by(workerId) %>%
  summarise(accept = !any(!accept))

table(worker_acceptance$accept)
## 
## FALSE  TRUE 
##    38    34

4.1 Rejection reasons

For convenience, we have (covertly) stored all information gathered in a table named worker_profile. Let’s have a look at how many participants are rejected the individual criteria:

## individual
rejection_reasons = worker_profile %>% 
  group_by(criterion, accept) %>% 
  tally() %>%
  spread(key = accept, value = n) %>%
  rename(acccept = 'TRUE', reject = 'FALSE')
criterion reject acccept
attention_2 30 40
attention|control_1 2 68
attention|control_2 5 65
control_1 70
control_2 9 61
control_related_1 4 66
control_related_2 12 58
control_unrelated_1 1 69
control_unrelated_2 6 64
meanRT 70
medianRT 70
progress 2 70
validRTs 9 61

As expected, many participants fail frequently on attention trials. As opposed to Forced Choice tasks, these can merely measure attention, but cannot draw participants attention to the area of the manipulation (and such improving performance in the future).

Let’s have a look at how these reasons combine, but, for the sake of simplicity, under restrictions to groups as proposed in Pieper et al. (2022), i.e. with separate evaulation of attention and control trials, but joined evaluation of related and unrelated controls.

## Combined Rejection Reasons 
rejection_reasons_combined = worker_profile %>%
  filter(accept == FALSE) %>%
  filter(!grepl("\\|",criterion) & !(grepl("related",criterion))) %>%
  group_by(workerId) %>%
  arrange(criterion) %>% 
  summarise(criteria = paste(criterion, collapse = " + ")) %>%
  group_by(criteria) %>% tally() %>%
  arrange(criteria)
criteria n
attention_2 19
attention_2 + control_2 5
attention_2 + control_2 + validRTs 1
attention_2 + validRTs 5
control_2 1
control_2 + validRTs 2
progress 2
validRTs 1

4.2 Final decision

If we do not want to apply certain criteria, we can delete them now from the worker profile:

As we find that enough participants passed attention trials (although it was required that all trials are responded to correctly), we do remove the group attention|control as it is hence not needed (and for illustration purposes):

worker_profile = worker_profile %>%
  ## restrict to attention and control as groups
  filter(!grepl("\\|",criterion) & !(grepl("related",criterion)))

4.3 Participants overview table

we might also check on individual participants:

worker_profile %>%
  mutate(score = ifelse(score > 1, 
                        score/1000, # seconds 
                        score*100) # percent
         ) %>%
  mutate(score = format(round(score, 2), nsmall = 2)) %>%
  select(-accept) %>%
  spread(key = criterion, value = score) %>%
  merge(worker_acceptance) %>%  relocate(accept) %>%
  mutate(accept = ifelse(accept,"yes","no")) %>%
  datatable(rownames = FALSE, extensions = 'Buttons',  options = list(
            columnDefs = list(list(className = 'dt-right',
                                   targets = 1:(1+length(unique(worker_profile$criterion)))))
            ))

4.4 Remove ineligible participants

Rejected Workers:

reject = worker_profile %>%
  filter(accept == FALSE) %>%
  pull(workerId) %>% unique() %>% sort()

length(reject)
## [1] 36
reject
##  [1] 130 131 132 137 138 139 147 148 150 155 158 159 160 170 171 172 174 175 177
## [20] 178 180 181 186 191 192 193 194 202 204 205 207 208 209 211 212 214
## 72 Levels: 128 130 131 132 133 134 135 136 137 138 139 147 148 149 150 ... 215

Remove their data from fillers:

filler_items = filler_items %>%
  filter(! workerId %in% reject)
write.csv(filler_items, "./judgments/eligible/LikertSkala_filler.csv", fileEncoding = "UTF-8", row.names = FALSE)

Remove their data from test items:

test_items = test_items %>%
  filter(! workerId %in% reject)
write.csv(test_items, "./judgments/eligible/LikertSkala_test.csv", fileEncoding = "UTF-8", row.names = FALSE)

References

Ben-Gal, I. (2005). Outlier detection. In O. Maimon & L. Rokach (Eds.), Data mining and knowledge discovery handbook (pp. 131–146). Springer US. https://doi.org/10.1007/0-387-25465-X_7
Frederick, R. I., & Speed, F. (2007). On the interpretation of below-chance responding in forced-choice tests. Assessment, 14, 3–11. https://doi.org/10.1177/1073191106292009
Häussler, J., & Juzek, T. S. (2016). Detecting and discouraging non-cooperative behavior in online experiments using an acceptability judgment task. In H. Christ, D. Klenovšak, L. Sönning, & V. Werner (Eds.), A blend of MaLT. Selected contributions from the methods and linguistic theory symposium 2015 (pp. 73–99). University of Bamberg Press.
Miller, J. (1991). Reaction time analysis with outlier exclusion: Bias varies with sample size. The Quarterly Journal of Experimental Psychology. Section A, Human Experimental Psychology, 43(4), 907—912. https://doi.org/10.1080/14640749108400962
Pieper, J., Börner, A. K., & Kiss, T. (2022). Identifying non-cooperative participation in web-based elicitation of acceptability judgments – how to get rid of noise in your data. https://ling.auf.net/lingbuzz/006514

  1. Miller (1991) proposes the values of 3 (very conservative), 2.5 (moderately conservative) or even 2 (poorly conservative). Häussler & Juzek (2016) suggest using an asymmetric criterion (using standard deviations) of -1.5 for the lower and +4 for the upper cutoff point.↩︎